home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Symtable.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  7.4 KB  |  254 lines  |  [TEXT/R*ch]
  1. (* symtable.ml : to assign numbers to global variables and so on *)
  2.  
  3. local
  4.   open Misc Nonstdio Obj Fnlib Config Mixture Const;
  5. in
  6.  
  7. (* Hashtables for numbering objects *)
  8.  
  9. type 'a numtable =
  10. {
  11.   num_cnt: int ref,              (* The current number *)
  12.   num_tbl: ('a, int) Hasht.t     (* The table *)
  13. };
  14.  
  15. fun new_numtable size =
  16.   { num_cnt = ref 0, num_tbl = Hasht.new size }
  17. ;
  18.  
  19. fun find_in_numtable (nt : ''a numtable) =
  20.   Hasht.find (#num_tbl nt)
  21. ;
  22.  
  23. fun enter_in_numtable (nt : ''_a numtable) key =
  24.   let val c = !(#num_cnt nt) in
  25.     #num_cnt nt := !(#num_cnt nt) + 1;
  26.     Hasht.insert (#num_tbl nt) key c;
  27.     c
  28.   end;
  29.  
  30. fun remove_from_numtable (nt : ''a numtable) key =
  31.   Hasht.remove (#num_tbl nt) key
  32. ;
  33.  
  34. (* Global variables *)
  35.  
  36. val global_table =
  37.   ref (new_numtable 1 : (QualifiedIdent * int) numtable)
  38.  
  39. and literal_table =
  40.   ref ([] : (int * StructConstant) list)
  41. ;
  42.  
  43. fun get_slot_for_variable (uid as (qualid, stamp)) =
  44.   find_in_numtable (!global_table) uid
  45.   handle Subscript =>
  46.     (msgIBlock 0;
  47.      msgEOL();
  48.      errPrompt "Value ";
  49.      msgString (#qual qualid); msgString "."; msgString (#id qualid);
  50.      if stamp <> 0 then (msgString "/"; msgInt stamp) else ();
  51.      msgString " hasn't been defined yet"; msgEOL();
  52.      msgEBlock();
  53.      raise Toplevel)
  54. ;
  55.  
  56. fun get_slot_for_defined_variable (uid as (qualid, stamp)) =
  57.   enter_in_numtable (!global_table) uid
  58. ;
  59.  
  60. fun get_slot_for_literal cst =
  61.   let val c = !(#num_cnt (!global_table)) in
  62.     #num_cnt(!global_table) := !(#num_cnt (!global_table)) + 1;
  63.     literal_table := (c, cst) :: !literal_table;
  64.     c
  65.   end;
  66.  
  67. fun number_of_globals () =
  68.   !(#num_cnt (!global_table))
  69. ;
  70.  
  71. fun defineGlobalValueAlias uid uid' =
  72.   let val slot = get_slot_for_variable uid' in
  73.     Hasht.insert (#num_tbl (!global_table)) uid slot
  74.   end;
  75.  
  76. (* The exception tags *)
  77.  
  78. val unknown_exn_name = ({qual="?", id="?"}, 0);
  79. val exn_tag_table = ref(new_numtable 1 : (QualifiedIdent * int) numtable);
  80. val tag_exn_table = ref(Array.fromList [] : (QualifiedIdent * int) Array.array );
  81.  
  82. fun get_num_of_exn (name, stamp) =
  83.   Hasht.find (#num_tbl (!exn_tag_table)) (name, stamp)
  84.   handle Subscript =>
  85.     let val c = enter_in_numtable (!exn_tag_table) (name, stamp)
  86.         val len = Array.length (!tag_exn_table)
  87.     in
  88.       if c < len then () else
  89.         let val new_len = 2 * len
  90.             val new_tag_exn_table = Array.array(new_len, unknown_exn_name)
  91.         in
  92.           Array.copy {src = !tag_exn_table, si = 0, len = NONE,
  93.                       dst = new_tag_exn_table, di = 0};
  94.           tag_exn_table := new_tag_exn_table
  95.         end;
  96.       Array.update(!tag_exn_table, c, (name, stamp));
  97.       c
  98.     end;
  99.  
  100. fun get_exn_of_num tag =
  101.   if tag >= Array.length (!tag_exn_table)
  102.   then unknown_exn_name
  103.   else Array.sub(!tag_exn_table, tag)
  104. ;
  105.  
  106. fun defineGlobalExceptionAlias (q, (q', stamp')) =
  107.   let val tag = get_num_of_exn (q', stamp') in
  108.     Hasht.insert (#num_tbl (!exn_tag_table)) (q, 0) tag
  109.   end;
  110.  
  111. fun intOfTag (CONtag(n,_)) = n
  112.   | intOfTag (EXNtag(id, stamp)) = get_num_of_exn(id, stamp)
  113. ;
  114.  
  115. (* The C primitives *)
  116.  
  117. val c_prim_table = ref (new_numtable 0 : string numtable);
  118.  
  119. fun set_c_primitives prim_vect =
  120.   (c_prim_table := new_numtable 31;
  121.    for (fn i => ignore
  122.           (enter_in_numtable (!c_prim_table) (Vector.sub(prim_vect, i))))
  123.        0 (Vector.length prim_vect - 1))
  124. ;
  125.  
  126. fun get_num_of_prim name =
  127.   find_in_numtable (!c_prim_table) name
  128.   handle Subscript =>
  129.     (msgIBlock 0;
  130.      errPrompt "Unavailable C primitive: ";
  131.      msgString name; msgEOL();
  132.      msgEBlock();
  133.      raise Toplevel)
  134. ;
  135.  
  136. fun exportPublicNames uname excRenList valRenList =
  137.   (List.app defineGlobalExceptionAlias excRenList;
  138.    List.app
  139.      (fn (id, stamp) =>
  140.          defineGlobalValueAlias
  141.            ({ qual=uname, id=id }, 0)
  142.            ({ qual=uname, id=id }, stamp))
  143.      valRenList)
  144. ;
  145.  
  146. (* Initialization *)
  147.  
  148. val normalizeExnName = fn
  149.     {qual="sys", id="Break"}     => {qual="General", id="Interrupt"}
  150.   | {qual="sys", id="Sys_error"} => {qual="General", id="SysErr"}
  151.   | {qual="exc", id="Not_found"} => {qual="General", id="Subscript"}
  152.   | {qual="io",  id="End_of_file"} => {qual="General", id="Size"}
  153.   | {qual="exc", id="Out_of_memory"} => {qual="General", id="Out_of_memory"}
  154.   | {qual="exc", id="Invalid_argument"} =>
  155.        {qual="General", id="Invalid_argument"}
  156.   | {qual="exc", id="Failure"}   => {qual="General", id="Fail"}
  157.   | {qual="graphics", id="Graphic_failure"} =>
  158.                           {qual="General", id="Graphic_failure"}
  159.   | {qual="general", id="Exception"} => {qual="General", id="(Exception)"}
  160.   | {qual="general", id=id}      => {qual="General", id=id}
  161.   | qualid => qualid
  162. ;
  163.  
  164. fun reset_linker_tables () =
  165. (
  166.   global_table := new_numtable 263;
  167.   literal_table := [];
  168.   List.app
  169.     (fn {qual, id} =>
  170.        ignore( get_slot_for_defined_variable ({qual="(global)", id=id}, 0) ))
  171.     Predef.predef_variables;
  172.   exn_tag_table := new_numtable 31;
  173.   tag_exn_table := Array.array(50, unknown_exn_name);
  174.   List.app
  175.     (fn (q, stamp) => ignore(get_num_of_exn (normalizeExnName q, 0)))
  176.     Predef.predef_exn;
  177.   set_c_primitives Prim_c.primitives_table
  178. );
  179.  
  180. fun save_linker_tables outstream =
  181. (
  182.   output_binary_int outstream (! (#num_cnt(!global_table)));
  183.   output_value outstream (!exn_tag_table);
  184.   output_value outstream (!tag_exn_table)
  185. );
  186.  
  187. (* To read linker tables from the executable file *)
  188.  
  189. fun load_linker_tables () =
  190.   ( let
  191.       val is = open_in_bin (Vector.sub(Miscsys.command_line, 0))
  192.       (* The code, data, symb, and debug indexes are located 20 bytes 
  193.          before the end of the bytecode file. *)
  194.       val () = seek_in is (in_stream_length is - 20)
  195.       val size_code = input_binary_int is
  196.       val size_data = input_binary_int is
  197.       val size_symb = input_binary_int is
  198.       val size_debug = input_binary_int is
  199.     in
  200.       seek_in is (in_stream_length is - 20 - size_debug - size_symb);
  201.       (* We don't need information about the internals *)
  202.       (* of Moscow ML system! *)
  203.       global_table := new_numtable 263;
  204.       #num_cnt (!global_table) := input_binary_int is;
  205.       exn_tag_table := input_value is;
  206.       tag_exn_table := input_value is
  207.     end
  208.   ) handle _ => fatalError "Unable to read linker tables from bytecode"
  209. ;
  210.  
  211. (* Initialization *)
  212.  
  213. prim_val available_primitives : unit -> string Vector.vector
  214.                                   = 1 "available_primitives";
  215.  
  216. fun init_linker_tables () =
  217. (
  218.   load_linker_tables();
  219.   (* Hasht.clear (#num_tbl (!global_table)); *)
  220.   appFrom
  221.     (fn slot => fn g =>
  222.        Hasht.insert (#num_tbl (!global_table)) (g, 0) slot)
  223.     0 Predef.predef_variables;
  224.   literal_table := [];
  225.   set_c_primitives (available_primitives())
  226. );
  227.  
  228. (* added -- 07Sep95 e *)
  229.  
  230. fun protect_linker_tables fct =
  231.   let val saved_global_table     = !global_table
  232.       and saved_literal_table    = !literal_table
  233.       and saved_exn_tag_table    = !exn_tag_table
  234.       and saved_tag_exn_table    = !tag_exn_table
  235.       and saved_c_prim_table     = !c_prim_table
  236.   in
  237.     (fct();
  238.      global_table            := saved_global_table;
  239.      literal_table           := saved_literal_table;
  240.      exn_tag_table           := saved_exn_tag_table;
  241.      tag_exn_table           := saved_tag_exn_table;
  242.      c_prim_table            := saved_c_prim_table
  243.      )
  244.     handle x =>
  245.       (global_table            := saved_global_table;
  246.        literal_table           := saved_literal_table;
  247.        exn_tag_table           := saved_exn_tag_table;
  248.        tag_exn_table           := saved_tag_exn_table;
  249.        c_prim_table            := saved_c_prim_table;
  250.        raise x)
  251.   end
  252.  
  253. end;
  254.